home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / acad / autolisp / ansimnu3 / menu3.lsp
Text File  |  1990-01-31  |  9KB  |  236 lines
  1. ;;; -*-  Mode: LISP -*- Syntax: AutoLISP (C) Benjamin Olasov 1988, 1989
  2.  
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;; File: MENU.LSP Copyright (C) Benjamin Olasov    Graphic Systems, Inc.   ;;;
  5. ;;; Inquiries:                                                              ;;;
  6. ;;;                                                                         ;;;
  7. ;;;     Benjamin Olasov                                                     ;;;
  8. ;;;     Graphic Systems, Inc.:                                              ;;;
  9. ;;;                                                                         ;;;
  10. ;;;                    New York, NY:   PH (212) 725-4617                    ;;;
  11. ;;;                    MCI-Mail:       GSI-NY   344-4003                    ;;;
  12. ;;;                    Arpanet:        olasov@cs.columbia.edu               ;;;
  13. ;;;                                                                         ;;;
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15.  
  16. ;; This program is provided 'as is' without warranty of any kind, either 
  17. ;; expressed or implied, including, but not limited to the implied warranties of
  18. ;; merchantability and fitness for a particular purpose.  The entire risk as to
  19. ;; the quality and performance of the program is with the user.  Should the 
  20. ;; program prove defective, the user assumes the entire cost of all necessary 
  21. ;; servicing, repair or correction. 
  22. ;; AutoLisp and AutoCad are registered trademarks of AutoDesk, Inc.
  23.  
  24.  
  25. ;; This function creates menus in text screen mode for AutoLISP.
  26. ;; It assumes an 80 column textscreen monitor and ANSI.SYS graphics device
  27. ;; MENU-OPERATION looks for and returns an integer.
  28.  
  29. ;; In this version, the header, prompt and individual items in the item-list
  30. ;; MUST all be strings, that is, surrounded by double quotes. ex.: "STRING"
  31. ;; The syntax is: 
  32. ;;
  33. ;; (menu-operation "header" '("item-1" "item-2" ... "item-n") "prompt")
  34.  
  35. (TEXTSCR)
  36.  
  37. (VMON)
  38.  
  39. (GC)
  40.  
  41. (princ "\nLoading- please wait... \\") 
  42.  
  43. (DEFUN MENU-OPERATION (HEADER ITEM-LIST PRMPT COLOR / HGT WDT I L-COL)
  44.        (MENU_INIT COLOR)
  45.        (PAINT_BKGRND TOP_MARG L_COL HGT WDT COLOR)
  46.        (PAINT_FRAME TOP_MARG L_COL HGT WDT)
  47.        (PRINT_HEADER TOP_MARG L_COL WDT)
  48.        (PRINT_ITEMS ITEM-LIST TOP_MARG L_COL COLOR)
  49.        (PRINT_PRMPT PRMPT TOP_MARG L_COL HGT)
  50.        (USR_VAL))
  51.  
  52. (princ "\rLoading- please wait... \|") 
  53.  
  54. (DEFUN MENU_INIT (COLOR)
  55.        (TEXTSCR)
  56.        (CLS)
  57.        (NORMAL)
  58.        (PRINC (STRCAT "\e[" (ITOA COLOR) "m"))
  59.        (IF (/= (REM (STRLEN HEADER) 2) 0) (SETQ HEADER (STRCAT HEADER " ")))
  60.        (SETQ HGT (+ 5 (LENGTH ITEM-LIST))
  61.              WDT (+ 10 (MAX (LONGEST ITEM-LIST) (STRLEN HEADER))))
  62.        (IF (/= (REM HGT 2) 0) (SETQ HGT (1+ HGT)))
  63.        (IF (/= (REM WDT 2) 0) (SETQ WDT (1+ WDT)))
  64.        (SETQ L_COL (- 40 (/ WDT 2))
  65.              i 0
  66.              TOP_MARG (- 12 (/ HGT 2))))
  67.  
  68. (princ "\rLoading- please wait... \/") 
  69.  
  70. (DEFUN PAINT_BKGRND (RW CL HT WD COLOR)
  71.        (IF (> COLOR 40)  ;;don't try to paint invisible backgrounds
  72.            (PROGN (GOTO (1+ RW) (1+ CL))
  73.                   (REPEAT (- HT 1)
  74.                           (REPEAT (- WD 2) (PRINC " " ))
  75.                                   (NEXTROW (- WD 2))))))
  76.  
  77. (princ "\rLoading- please wait... \-") 
  78.  
  79. (DEFUN PAINT_FRAME (RW CL HT WD)
  80.        (GOTO RW CL)           ;; position cursor at top left corner of frame 
  81.        (PRINC (CHR 201))      ;; paint top left corner of frame
  82.        (REPEAT (- WD 2)       ;; paint top of frame
  83.                (PRINC (CHR 205)))
  84.        (PRINC (CHR 187))      ;; paint top right corner of frame
  85.        (REPEAT 3
  86.                (NEXTROW WD)
  87.                (PRINC (CHR 186))      ;; print side-of-frame char
  88.                (MOVE (- WD 2) "C")    ;; move to right side of frame
  89.                (PRINC (CHR 186)))     ;; print side-of-frame char
  90.        (NEXTROW WD)
  91.        (PRINC (CHR 204))                     ;;paint middle bar
  92.        (REPEAT (- WDT 2) (PRINC (CHR 205)))
  93.        (PRINC (CHR 185))
  94.        (REPEAT (- HT 5)
  95.                (NEXTROW WD)
  96.                (PRINC (CHR 186))      ;; print side-of-frame char
  97.                (MOVE (- WD 2) "C")    ;; move to right side of frame
  98.                (PRINC (CHR 186)))     ;; print side-of-frame char
  99.        (NEXTROW WD)
  100.        (PRINC (CHR 200))
  101.        (REPEAT (- WDT 2) (PRINC (CHR 205)))
  102.        (PRINC (CHR 188)))
  103.  
  104. (princ "\rLoading- please wait... \\") 
  105.  
  106. (DEFUN PRINT_HEADER (RW CL WD)
  107.        (GOTO (+ RW 3)
  108.              (+ CL (- (/ WD 2) (/ (STRLEN HEADER) 2))))
  109.        (BOLD)
  110.        (PRINC HEADER)
  111.        (NORMAL))
  112.  
  113. (DEFUN PRINT_HEADER (RW CL WD)
  114.        (GOTO (+ RW 2)
  115.              (+ CL (- (/ WD 2) (/ (STRLEN HEADER) 2))))
  116.        (BOLD)
  117.        (PRINC HEADER))
  118.  
  119. (princ "\rLoading- please wait... \|") 
  120.  
  121. (DEFUN PRINT_ITEMS (ITM_LST RW CL COLOR)
  122.        (PRINC (STRCAT "\e[0m\e[" (ITOA COLOR) "m")) ;;restore normal screen
  123.        (SETQ I 0)                                   ;;& then init user color
  124.        (FOREACH ITEM ITM_LST
  125.                 (SETQ I (1+ I))
  126.                 (GOTO (+ RW 4)
  127.                       (+ CL 2))
  128.                 (MOVE I "B")     ;; move I spaces down
  129.                 (PRINC (STRCAT " "
  130.                                (IF (< I 10) " " "")
  131.                                (RTOS (FLOAT I) 2 0) "] " ITEM))))
  132.  
  133. (princ "\rLoading- please wait... \/") 
  134.  
  135. (DEFUN PRINT_PRMPT (PRMPT RW CL HT)
  136.        (NORMAL)
  137.        (GOTO (+ RW HT 3) 0)
  138.        (PRINC PRMPT)
  139.        (GC))
  140.  
  141. (princ "\rLoading- please wait... \-") 
  142.  
  143. (DEFUN USR_VAL ()
  144.        (NORMAL)
  145.        (SETQ CHOICE (GETINT))
  146.        (WHILE (OR (< CHOICE 1) (> CHOICE (LENGTH ITEM-LIST)))
  147.               (SETQ CHOICE (GETINT "Choice is out of range, try again: ")))
  148.        (CLS) CHOICE)
  149.  
  150. ;;length of longest string in a list of strings
  151. (princ "\rLoading- please wait... \\") 
  152.  
  153. (DEFUN LONGEST (LST)
  154.        (APPLY 'MAX (MAPCAR '(LAMBDA (ITM) (STRLEN ITM)) LST)))
  155.  
  156. (princ "\rLoading- please wait... \|") 
  157.  
  158. (DEFUN BOLD ()
  159.        (PRINC "\e[1m"))
  160.  
  161. (princ "\rLoading- please wait... \/") 
  162.  
  163. (DEFUN NORMAL ()
  164.        (PRINC "\e[0m"))
  165.  
  166. ;; This an an example of using MENU-OPERATION to get a value from the user.
  167. ;; The first argument must be the header.
  168. ;; The second argument must be a list of things to be chosen from.
  169. ;; The third argument must be a prompt [question] to the user.
  170. ;; MENU-OPERATION looks for and returns an integer.
  171.  
  172. (princ "\rLoading- please wait... \-") 
  173.  
  174. (defun c:test ()
  175.        (setq woodtype 
  176.           (menu-operation "WOOD MENU"
  177.                '("Cedar, western red"
  178.                  "Cedar, northern or southern white"
  179.                  "Cypress, southern"
  180.                  "Douglas fir, western"
  181.                  "Douglas fir, Rocky mountain region"
  182.                  "Fir, balsam"
  183.                  "Fir, golden"
  184.                  "Hemlock, eastern"
  185.                  "Larch, western"
  186.                  "Oak, commerical white or red"
  187.                  "Tamarack, eastern")
  188.                  "Select number corresponding to type of wood to be used: " 
  189.                   (ran_color) )))
  190.  
  191. (princ "\rLoading- please wait.. \\")
  192.  
  193. (DEFUN RVRS ()
  194.        (PRINC "\e[7m"))
  195.  
  196. (princ "\rLoading- please wait.. \|")
  197.  
  198. (defun MOVE (NO DIR) ;;DIR ARG: A=UP   B=DOWN   C=RIGHT   D=LEFT
  199.        (princ (strcat "\e[" (itoa NO) DIR)))
  200.  
  201. (princ "\rLoading- please wait... \/") 
  202.  
  203. (defun CLS () (textscr)
  204.        (princ "\e[2J"))
  205.  
  206. (princ "\rLoading- please wait... \-") 
  207.  
  208. (defun goto (ROW COL)
  209.        (princ (strcat "\e[" (itoa row) "\;" (itoa col) "H")))
  210.  
  211. (princ "\rLoading- please wait... \\") 
  212.  
  213. (defun nextrow (cols)
  214.        (princ (strcat "\e[" (itoa cols) "D" "\e[1B")))
  215.  
  216. (princ "\rLoading- please wait... \|") 
  217.  
  218. (defun ran_color (/ *s)
  219.        (setq s (if s (rem (+ (* s 15625.7) 0.21137152) 1)
  220.                       0.3171943)
  221.              s (* 50 s))
  222.        (cond ((< s 31) (setq *s (fix (max 31 (/ (+ s 46) 2)))))
  223.              ((> s 46) (setq *s (fix (min 46 (/ (+ s 31) 2)))))
  224.              (T (setq *s (fix s)))))
  225.  
  226. (princ "\e[2J")
  227. (princ "\nThis menu system is written for the ANSI graphics standard.")
  228. (princ "\nIf your screen didn't just clear, you need to add the line:")
  229. (princ "\n\nDEVICE=ANSI.SYS\n")
  230. (princ "\nto your CONFIG.SYS file in order to use MENU-OPERATION.")
  231. (princ "\n\nThe syntax is: ")
  232. (princ "\n\n\(menu-operation \"header\" '(\"item-1\" \"item-2\" ... \"item-n\") \"prompt\"\)")
  233. (princ "\n\nType TEST to try a sample menu.")
  234. (princ)
  235.  
  236.